Mac-Source 1994 July/Mac-Source_July_1994.iso/Other Langs/PowerLisp 1.01/Library/cl.lisp

Text File | 1993-08-30 | 16.6 KB | 668 lines | [TEXT/ROSA]

;
;        Copyright © 1993 Roger Corman. All rights reserved.
;

;
;        Lisp standard functions and macros to be loaded at startup.
;

(in-package "COMMON-LISP")
(export '(    if
            when
            unless
            prog1
            prog2
            loop
            assert
            warn
            push
            pushnew
            pop
            ecase
            incf
            decf
            multiple-value-list
            multiple-value-setq
            multiple-value-bind
            functionp
            position
            find
            svref array-rank-limit array-dimension-limit array-total-size-limit
            read-from-string
            read-function dump-hash-table printcolumn spaces
            print-function prompt *prompt* show-lisp-symbols disassemble
            print-addr
            print-code
            proclaim
            copyright
            require
            provide
            defasm
            hex
            compile
            compile-file
            compile-without-assembling
            identity
            finish-output force-output clear-output
            *features*
            *modules*
            *load-verbose*
            *load-print*
            *gc-verbose*
            *lisp-file-extension*
            *lisp-compiled-file-extension*
            *library-directory*
            *top-level*
            pi
            internal-time-units-per-second
            time))

(setq *print-case* :downcase)    ; can be :upcase, :downcase or :capitalize

; Some Common Lisp special variables
(defvar *features* nil)
(defvar *modules* nil)
(defvar *read-suppress* nil)
(defvar *top-level* nil)

;
;    The *library-directory* special variable is used by
;    the 'require' function to figure out where to load
;    requested modules from.
;
(defconstant *library-directory* ":library:")
(defconstant *lisp-file-extension* ".lisp")
(defconstant *lisp-compiled-file-extension* ".compiled-lisp")

(defun compile (name &optional definition)
    (require :compiler)
    (compiler::compile name definition))

(defun compile-file (input-file &key (output-file "untitled.compiled-lisp") print)
    "Usage: (COMPILE-FILE input-filename :OUTPUT-FILE output-filename)"
    (require :compiler)
    (editor-message (format nil "Compiling file ~A…" input-file))
    (compiler::compile-file input-file output-file print))

(defun compile-without-assembling (name &optional definition)
    (require :compiler)
    (compiler::compile-without-assembling name definition))

;
;    Common Lisp 'prog1' macro
;
(defmacro prog1 (first-x &rest rest-x)
    `(let* ((a1 ,first-x))
        ,@rest-x
        a1))

;
;    Common Lisp 'prog2' macro
;
(defmacro prog2 (first-x second-x &rest rest-x)
    `(let* ((a1 ,first-x) (a2 ,second-x))
        ,@rest-x
        a2))

;
;    Simple version of LOOP macro
;
(defmacro loop (&rest forms)
    (dolist (f forms)
        (if (symbolp f)        ;; need expanded macro
            (progn
                (require :loop)
                (return-from loop `(loop ,@forms)))))
    (let ((sym (gensym)))
        `(block nil (tagbody ,sym ,@forms (go ,sym)))))

;
;    Common Lisp 'assert' macro
;
(defmacro assert (x)
    `(if (null ,x) (error "Assertion failed")))

;
;    Common Lisp 'warn' function.
;    This should really go to error-output stream.
;
(defun warn (format-string &rest args)
    (format t "~%Warning: ")
    (apply #'format t format-string args)
    (format t "~%"))

;
;    Common Lisp 'proclaim' function.
;    These are currently ignored.
;
(defun proclaim (decl)
    nil)

;
;    Common Lisp 'require' function.
;    The path-name option is not implemented yet.
;
(defun require (module-name &optional path-name)
    (if path-name
        (progn
            (format t "require: path-name option not implemented~%")
            (format t "Searching default directory: ~A~%"
                *library-directory*)))

    (if (symbolp module-name)
        (setq module-name (symbol-name module-name)))

    ;; load the module if necessary
    (if (not (member module-name *modules* :test #'equal))
        (let ((filename (concatenate 'string *library-directory*
                    module-name *lisp-file-extension*))
              (compiled-filename (concatenate 'string *library-directory*
                      module-name *lisp-compiled-file-extension*)))
            (cond
                ((probe-file compiled-filename)
                 (load compiled-filename))
                ((probe-file filename)
                 (load filename))
                (t (error "Can't locate the required module: ~A~%" module-name)))))

    ;; if it still doesn't exist, signal an error
    (if (not (member module-name *modules* :test #'equal))
        (error "Could not provide the required module: ~A~%" module-name))

    module-name)

;
;    Common Lisp 'provide' function.
;
(defun provide (module-name)
    (if (symbolp module-name)
        (setq module-name (symbol-name module-name)))
    (push module-name *modules*)
    module-name)

;
;
;    Common Lisp 'incf' macro
;    This currently does not completely conform to the standard because
;    subexpressions are evaluated twice.
;
(defmacro incf (place &optional (delta 1))
    `(setf ,place (+ ,place ,delta)))
 ;(defmacro incf ((place-func &optional expr) &optional (delta 1))
;(defmacro incf ((place-func &optional expr) &optional (delta 1))
;    (let ((sym (gensym)))
;        `(let ((,sym ,expr)) (setf ,(list place-func sym) (+ ,(list place-func sym) ,delta)))))
 ;
;
;    Common Lisp 'decf' macro
;    This currently does not completely conform to the standard because
;    subexpressions are evaluated twice.
;
(defmacro decf (place &optional (delta 1))
    `(setf ,place (- ,place ,delta)))

;
;    Common Lisp 'push' macro
;    This currently does not completely conform to the standard because
;    subexpressions are evaluated twice.
;
(defmacro push (val stack)
    (let ((item val) (place stack))
        `(setf ,place (cons ,item ,place))))

;
;    Common Lisp 'pushnew' macro
;    This currently does not completely conform to the standard because
;    subexpressions are evaluated twice.
;
(defmacro pushnew (item place &key test test-not key)
    `(setf ,place (adjoin ,item ,place)))

;
;    Common Lisp 'multiple-value-list' macro
;
(defmacro multiple-value-list (form)
    `(multiple-value-call #'list ,form))

;
;    Common Lisp 'multiple-value-setq' macro
;
(defmacro multiple-value-setq (varlist form)
    (let ((setq-forms nil)
          (value-list-sym (gensym))
          (return-form-sym (gensym)))
        (do ((v varlist (cdr v)) (count 0 (1+ count)))
            ((null v))
            (push
                `(setq ,(car v) (nth ,count ,value-list-sym))
                setq-forms))
        `(let* ((,value-list-sym (multiple-value-list ,form))
                (,return-form-sym (car ,value-list-sym)))
            ,@(reverse setq-forms)
            ,return-form-sym)))

;
;    Common Lisp 'multiple-value-bind' macro
;
(defmacro multiple-value-bind (vars value-form &rest forms)
    (let ((sym (gensym)))
        `(let ,vars
            (multiple-value-setq ,vars ,value-form)
            ,@forms)))

;
;    Common Lisp 'pop' macro
;    This currently does not completely conform to the standard because
;    subexpressions are evaluated twice.
;
(defmacro pop (stack)
    (let ((place stack))
        `(prog1 (car ,place) (setf ,place (cdr ,place)))))

;
;    Common Lisp 'ecase' macro.
;
(defmacro ecase (key &rest clauses)
    `(case ,key ,@clauses (otherwise (error "No matching key found in ecase form."))))

;
;    Set up the reader macro which allows for #| ... |# type comments
;
(set-dispatch-macro-character #\# #\|
    #'(lambda (stream char int)
            (do ((c (read-char stream) (read-char stream)))
                 ((and (char= c #\|) (char= (peek-char nil stream) #\#))
                         (read-char stream)(values)) nil)))

;
;    Set up the reader macro which allows for #+ conditional reads
;
(set-dispatch-macro-character #\# #\+
    #'(lambda (stream char int)
        (let ((feature (read stream)))
            (if (and (symbolp feature) (member feature *features*))
                (return (read stream)))

            ; else need to skip over the next expression
            (let ((*read-suppress* t)))
                (read stream))
            (return (values))))

;
;    Set up reader macro for octal, binary and hex numbers
;    #onnn -> octal, #bnnn ->binary, #xnnn ->hex
;
(set-dispatch-macro-character #\# #\O
    #'(lambda (stream char int)
        (let ((*read-base* 8))
            (read stream))))

(set-dispatch-macro-character #\# #\B
    #'(lambda (stream char int)
        (let ((*read-base* 2))
            (read stream))))

(set-dispatch-macro-character #\# #\X
    #'(lambda (stream char int)
        (let ((*read-base* 16))
            (read stream))))

;
;    SETF expansion functions
;
(defmacro defsetf (sym func)
    `(putprop ',sym '_setf_expansion_ ',func))

(defsetf symbol-value set)
(defsetf symbol-function $set-symbol-function)
(defsetf macro-function $set-macro-function)
(defsetf documentation put-documentation)
(defun %setcar (c x) (rplaca c x) x)
(defsetf car %setcar)
(defun %setcdr (c x) (rplacd c x) x)
(defsetf cdr %setcdr)
(defsetf rest %setcdr)
(defun %setcaar (x val) (setf (car (car x)) val))
(defsetf caar %setcaar)
(defun %setcadr (x val) (setf (car (cdr x)) val))
(defsetf cadr %setcadr)
(defun %setcdar (x val) (setf (cdr (car x)) val))
(defsetf cdar %setcdar)
(defun %setcddr (x val) (setf (cdr (cdr x)) val))
(defsetf cddr %setcddr)
(defsetf elt setelt)
(defsetf aref _set-aref)
(defun svref (vec index) (elt vec index))
(defun _setsvref (vec index val) (setelt vec index val))
(defsetf svref _setsvref)
(defsetf get putprop)
(defsetf gethash addhash)
(defsetf fill-pointer _set_fill_pointer)
(defun %setfirst (s x) (setelt s 0 x))
(defsetf first %setfirst)
(defun %setsecond (s x) (setelt s 1 x))
(defsetf second %setsecond)
(defun %setthird (s x) (setelt s 2 x))
(defsetf third %setthird)
(defun %setfourth (s x) (setelt s 3 x))
(defsetf fourth %setfourth)
(defun %setfifth (s x) (setelt s 4 x))
(defsetf fifth %setfifth)
(defun %setsixth (s x) (setelt s 5 x))
(defsetf sixth %setsixth)
(defun %setseventh (s x) (setelt s 6 x))
(defsetf seventh %setseventh)
(defun %seteighth (s x) (setelt s 7 x))
(defsetf eighth %seteighth)
(defun %setninth (s x) (setelt s 8 x))
(defsetf ninth %setninth)
(defun %settenth (s x) (setelt s 9 x))
(defsetf tenth %settenth)

;
;    constants for Common Lisp
(defconstant array-rank-limit 8)
(defconstant array-dimension-limit 2147483647)
(defconstant array-total-size-limit 2147483647)
(defconstant internal-time-units-per-second 1000000)
(defconstant pi 3.14159265358979323846)

(defvar *load-verbose* nil)
(defvar *load-print* nil)

(defun %is-binary (input-stream)
    (let ((x (read-byte input-stream)))
        (file-position input-stream 0)
        (return (= x 0))))

(defun load (filename
        &key (verbose *load-verbose*)
             (print *load-print*)
             if-does-not-exist)
    (editor-message (format nil "Loading file ~A…" filename))
    (let*
        ((loaded 0)
         (stream nil)
         (binary nil)
         (*package* *package*)            ;; bind these to themselves
         (*readtable* *readtable*)
         (*standard-output* *standard-output*))

        (if (symbolp filename)
            (setq filename (symbol-name filename)))
        (if (not (stringp filename))
            (error "Invalid file name"))

        (setq stream (open filename))
        (setq binary (%is-binary stream))

        (if binary
            (progn
                (if verbose
                    (progn
                        (format t ";;~%")
                        (format t ";; Loading compiled file: ~A~%" filename)
                        (format t ";;~%")))

                (do* ((expr t))
                    ((null expr)(close stream)(return-from load loaded))
                    (setq expr (%read-code-from-stream stream))
                    (if expr
                        (progn
                            (setq expr (funcall expr))
                            (if print (print expr))
                            (incf loaded))))))

        (if verbose
            (progn
                (format t ";;~%")
                (format t ";; Loading file: ~A~%" filename)
                (format t ";;~%")))

        (do* ((expr nil))
            ((eq expr 'Eof)(close stream)(return-from load loaded))
            (setq expr (read stream nil))
            (if (not (eq expr 'Eof))
                (progn
                    (setq expr (eval expr))
                    (if print (print expr))
                    (incf loaded))))))

;;
;;    Common Lisp 'defun' macro.
;;    This redefines the built-in special form.
;;
(defmacro defun (name lambda-list &rest forms)
    (let ((doc-form nil) (lambda-form nil))
        (if (and (typep (car forms) 'string)
                (cdr forms))
            (progn
                (setq doc-form
                    `((setf (documentation ',name 'function) ,(car forms))))
                (setq forms (cdr forms))))

        (setq lambda-form
            `(lambda ,lambda-list
                (block ,name ,@forms)))
        `(progn
            ,@doc-form
            (setf (symbol-function ',name) (function ,lambda-form))
            (null-environment (function ,name))
            ',name)))

;;
;;    Common Lisp 'defmacro' macro.
;;    This redefines the built-in special form.
;;
(defmacro defmacro (name lambda-list &rest forms)
    (let ((doc-form nil) (lambda-form nil))
        (if (and (typep (car forms) 'string) (cdr forms))
            (progn
                (setq doc-form
                    `((setf (documentation ',name 'macro) ,(car forms))))
                (setq forms (cdr forms))))

        (setq lambda-form
            `(lambda (form &optional env)
                (destructuring-bind ,lambda-list
                    (cdr form)
                    (block ,name ,@forms))))
        `(progn
            ,@doc-form
            (setf (macro-function ',name) (function ,lambda-form))
            (null-environment (macro-function ',name))
            ',name)))

;
;    Common Lisp 'time' macro.
;
;
(defmacro time (x)
    `(let ((tm (get-internal-run-time)) ret)
        (setq ret ,x)
        (setq tm (- (get-internal-run-time) tm))
        (decf tm (%elapsed-time nil))    ;; subtract timer overhead
        (setq tm (/ (float tm) 1000000.0))
        (format *trace-output* "Execution time: ~A seconds~%" tm)
        ret))

; This private macro '%elapsed-time' acts like time, but returns the
; time elapsed after evaluating the passed expression.
;
(defmacro %elapsed-time (x)
    `(let ((tm (get-internal-run-time)) ret)
        (setq ret ,x)
        (setq tm (- (get-internal-run-time) tm))
        tm))

;
;    Common Lisp 'functionp' function.
;
(defun functionp (x) (typep x 'function))

;
;    Common Lisp 'position' function.
;    To do:     Add :test-not option.
;
(defun position (item sequence
        &key from-end (test #'eql) test-not (start 0) end key)
    (unless (integerp end) (setq end (length sequence)))
    (unless (typep sequence 'sequence) (error "Not a sequence"))
    (if test-not (error ":test-not key not implemented"))
    (if from-end
        ;; loop backward
        (do ((i (1- end) (- i 1)))
                ((< i start) nil)
                (if (apply test (list (elt sequence i) item))
                    (return i)))

        ;;; else go forward
        (do ((i start (+ i 1)))
                ((>= i end) nil)
                (if (apply test (list (elt sequence i) item))
                    (return i)))))

;
;    Common Lisp 'find' function.
;    To do:     Add :test-not option.
;
(defun find (item sequence
        &key from-end (test #'eql) test-not (start 0) end key)
    (unless (integerp end) (setq end (length sequence)))
    (unless (typep sequence 'sequence) (error "Not a sequence"))
    (if test-not (error ":test-not key not implemented"))
    (if from-end
        ;; loop backward
        (do ((i (1- end) (- i 1)) (x))
                ((< i start) nil)
                (setq x (elt sequence i))
                (if (apply test (list x item))
                    (return x)))

        ;;; else go forward
        (do ((i start (+ i 1)) (x))
                ((>= i end) nil)
                (setq x (elt sequence i))
                (if (apply test (list x item))
                    (return x)))))

;
;    Common Lisp 'read-from-string' function.
;    To do: handle eof-error, eof-value, preserve-whitespace settings
;
(defun read-from-string (string &optional eof-error eof-value
            &key (start 0) end preserve-whitespace
            &aux string-stream expr position)
    (if (not (typep string 'string)) (error "Not a string"))
    (if (not end) (setq end (length string)))
    (setq string-stream (make-string-input-stream string start end))
    (setq expr (read string-stream))
    (setq position (file-position string-stream))
    (if (eq position 'Eof) (setq position (- end start)))
    (values expr position))

;;
;;    Normal top level user input function.
;;    This will get executed at startup and for the duration of an
;;    interactive session.
;;    By default, this function is the value of the variable *top-level*.
;;
(defun top-level ()
    (do (expr)
        (nil)
        (catch 'common-lisp::%error
            (progn
                (setq expr (read))
                (if (eq expr 'quit)
                    (return))
                (if (eq expr 'Eof)
                    (return 'Eof))
                (editor-message "Thinking…")    ;; display status message
                (setq expr (multiple-value-list (eval expr)))
                (format t "~A~{ ~A~}~%" (car expr) (cdr expr))))))

(setq *top-level* #'common-lisp::top-level)

;
;    Common Lisp 'identity' function.
;
(defun identity (object) object)

(defun finish-output (&optional (stream *standard-output*))
    (file-flush stream))

(defun force-output (&optional (stream *standard-output*))
    (file-flush stream))

(defun clear-output (&optional (stream *standard-output*))
    (file-flush stream))

;
;    This allows the #{ (assembly code) } syntax
;
(set-dispatch-macro-character #\# #\{
    #'(lambda (stream char int)
        (require :assembler)
        (let ((*package* (find-package :assembler)))
            (assemble (read-delimited-list #\} stream) nil))))

(defun defasm (&rest x)
    (error "Assembler package not loaded"))

(defun hex (x)
    (let ((*print-base* 16))
        (write x))
    (values))

(defun printcolumn (s)
    (dolist (x s) (print x)))

(defun disassemble (a)
    (let ((*print-base* 16))
        (printcolumn (disassembly-list a))))

(defun prompt ()
    (let ((savep *print-escape*))
        (setq *print-escape* nil)
        (write "free: ")
        (write (free))
        (write ">")
        (write "\n")
        (setq *print-escape* savep)))

;; Print an executable address in hex
(defun print-code (x)
    (let ((*print-base* 16))
        (print (exec-address x))))

;; Print an object address in hex
(defun print-addr (x)
    (let ((*print-base* 16))
        (print (address x))))

(defun gc-hook-default-function (nodes-freed)
    (if *gc-verbose*
        (progn
            (format t "Garbage collection: ~A nodes were freed.~%" nodes-freed)
            (file-flush))))

(defvar *gc-hook* #'gc-hook-default-function)
(defvar *gc-verbose* nil)        ;; set this to T to get garbage collection messages